COMMENT ⊗   VALID 00002 PAGES
C REC  PAGE   DESCRIPTION
C00001 00001
C00002 00002	block4.lsp[f83,jmc]	Block stacker that looks for safe moves first
C00008 ENDMK
C⊗;
block4.lsp[f83,jmc]	Block stacker that looks for safe moves first
;;; block3.lsp[f83,jmc]	Block stacker with fn calls and opportunism
;;; The opportunism consists of moving a block to its final destination
;;; instead of the table during clear operations if this is possible.
;;; Additional opportunism: Making a move to final position when possible.

(defun build (structure s)
       (if (null structure)
	   s
	   (build (cdr structure)
		   (build1 structure (reverse (car structure)) 'table s))))
;;; Since we build towers from the bottom, BUILD1 works better with
;;; a reversed tower as argument.

(defun build1 (st rtower location s)
       (if (null rtower)
	   s
	   (build1 st (cdr rtower) (car rtower)
		  (move st (car rtower) location s))))

(defun move (st block location s)
       (if (on block location (car s)) 
	   s
	   (immove block
		   location
		   (clear st block (clear st location s)))))

(defun immove (block location s)
       (cons (update
	      (car s)
	      (list block location))
	     (cons (list block location) (cdr s))))

(defun clear (st block s)
       (if (or (null block) (eq block 'table))
	   s
	   (clear1 st block (find block (car s)) s)))

(defun update1 (s1 pair)
       (cond
	((or (null s1) (and (null (car pair)) (null (cadr pair))))
	 s1)
	((eq (caar s1) (car pair))
	 (cons (cdar s1) (update1 (cdr s1) pair)))
	((eq (caar s1) (cadr pair))
	 (cons (cons (car pair) (car s1))
	       (update1 (cdr s1) (list (car pair) nil))))
	(t
	 (cons (car s1) (update1 (cdr s1) pair)))))

(defun update (s1 pair)
       (update2 (if (eq (cadr pair) 'table)
		    (cons (list (car pair)) (update1 s1 (cons (car pair) nil)))
		    (update1 s1 pair))))

(defun update2 (s1) (cond
		     ((null s1) nil)
		     ((null (car s1)) (cdr s1))
		     (t (cons (car s1) (update2 (cdr s1))))))

(defun find (b s1) (if (member b (car s1)) (car s1) (find b (cdr s1))))

(defun clear1 (st b tower s)
       (if (eq b (car tower))
	   s
	   (clear1
	    st
	    b
	    (cdr tower)
	    (immove
	     (car tower)
	     ((lambda (w) (if (member w (car s)) (car w) 'table))
	      (dest (car tower) st))
	     s))))

(defun dest (b st) (dest2 b (dest1 b st)))

(defun dest1 (b st) (if (member b (car st)) (car st) (dest1 b (cdr st))))

(defun dest2 (b tower) (if (eq (car tower) b)
			   (if (null (cdr tower)) 'table (cdr tower))
			   (dest2 b (cdr tower))))

(defun isclear (b st) (eq b (car (dest1 b st))))

(defun on (a b s1) (on1 a b (find a s1)))
       
(defun on1 (a b tower)
       (and (not (null tower))
	    (or (and (eq (car tower) a)
		     (or (and (eq b 'table) (null (cdr tower)))
			 (and (not (null (cdr tower))) (eq (cadr tower) b))))
		(on1 a b (cdr tower)))))

;;; tests
(setq t1 '((a b) (c)))
(setq t2 '((a b c)))
(setq s0 (cons t1 nil))
(setq tt0 '(b c))
(immove 'a 'c s0)
(move t2 'a 'c s0)
(immove 'a 'table s0)
(build1 t2 '(c) 'a s0)
(build1 t2 '(c b) 'table s0)
(build t2 s0)
(setq t3 '((a b c) (d e) (f)))
(setq t4 '((a b c d f) (e)))
(build t4 (cons t3 nil))
(setq t5 '((c b) (a d e) (f)))
(build t5 (cons t3 nil))
(setq t6 '((c b) (a d) (e f)))
(build t6 (cons t3 nil))